home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / vm / vm-menu.el < prev    next >
Encoding:
Text File  |  1995-08-08  |  37.8 KB  |  1,156 lines
  1. ;;; Menu related functions and commands
  2. ;;; Copyright (C) 1995 Kyle E. Jones
  3. ;;;
  4. ;;; Folders menu derived from
  5. ;;;     vm-folder-menu.el
  6. ;;;     v1.10; 03-May-1994
  7. ;;;     Copyright (C) 1994 Heiko Muenkel
  8. ;;;     email: muenkel@tnt.uni-hannover.de
  9. ;;;  Used with permission and my thanks.
  10. ;;;  Changed 18-May-1995, Kyle Jones
  11. ;;;     Cosmetic string changes, changed some variable names
  12. ;;;     and interfaced it with FSF Emacs via easymenu.el.
  13. ;;;   
  14. ;;; Tree menu code is essentially tree-menu.el with renamed functions
  15. ;;;     tree-menu.el
  16. ;;;     v1.20; 10-May-1994
  17. ;;;     Copyright (C) 1994 Heiko Muenkel
  18. ;;;     email: muenkel@tnt.uni-hannover.de
  19. ;;;
  20. ;;;  Changed 18-May-1995, Kyle Jones
  21. ;;;    Removed the need for the utils.el package and references thereto.
  22. ;;;    Changed file-truename calls to tree-menu-file-truename so
  23. ;;;    the calls could be made compatible with FSF Emacs 19's
  24. ;;;    file-truename function.
  25. ;;;  Changed 30-May-1995, Kyle Jones
  26. ;;;    Renamed functions: tree- -> vm-menu-hm-tree.
  27. ;;;  Changed 5-July-1995, Kyle Jones
  28. ;;;    Removed the need for -A in ls flags.
  29. ;;;    Some systems' ls don't support -A.
  30. ;;;
  31. ;;; This program is free software; you can redistribute it and/or modify
  32. ;;; it under the terms of the GNU General Public License as published by
  33. ;;; the Free Software Foundation; either version 1, or (at your option)
  34. ;;; any later version.
  35. ;;;
  36. ;;; This program is distributed in the hope that it will be useful,
  37. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  38. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  39. ;;; GNU General Public License for more details.
  40. ;;;
  41. ;;; You should have received a copy of the GNU General Public License
  42. ;;; along with this program; if not, write to the Free Software
  43. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  44.  
  45. (provide 'vm-menu)
  46.  
  47. (defun vm-menu-fsfemacs-menus-p ()
  48.   (and (vm-fsfemacs-19-p)
  49.        (fboundp 'menu-bar-mode)))
  50.  
  51. (defun vm-menu-xemacs-menus-p ()
  52.   (and (vm-xemacs-p)
  53.        (fboundp 'set-buffer-menubar)))
  54.  
  55. ;; defined again in vm-misc.el but we need it here for some
  56. ;; initializations.  The "noautoload" vm.elc won't work without
  57. ;; this.
  58. (defun vm-fsfemacs-19-p ()
  59.   (and (string-match "^19" emacs-version)
  60.        (not (string-match "XEmacs\\|Lucid" emacs-version))))
  61.  
  62. (defvar vm-menu-folders-menu 
  63.   '("Manipulate Folders"
  64.     ["Make Folders Menu" vm-menu-hm-make-folder-menu vm-folder-directory])
  65.   "VM folder menu list.")
  66.  
  67. (defconst vm-menu-folder-menu
  68.   (list
  69.    "Folder"
  70.    (if (vm-fsfemacs-19-p)
  71.        ["Manipulate Folders" ignore (ignore)]
  72.      vm-menu-folders-menu)
  73.    "---"
  74.    ["Display Summary" vm-summarize t]
  75.    ["Toggle Threading" vm-toggle-threads-display t]
  76.    "---"
  77.    ["Get New Mail" vm-get-new-mail (vm-menu-can-get-new-mail-p)]
  78.    "---"
  79.    ["Search" vm-isearch-forward vm-message-list]
  80.    "---"
  81.    ["Auto-Archive" vm-auto-archive-messages vm-message-list]
  82.    ["Expunge" vm-expunge-folder vm-message-list]
  83.    "---"
  84.    ["Visit Folder" vm-visit-folder t]
  85.    ["Revert Folder (back to disk version)" revert-buffer (vm-menu-can-revert-p)]
  86.    ["Recover Folder (from auto-save file)" recover-file (vm-menu-can-recover-p)]
  87.    ["Save" vm-save-folder (vm-menu-can-save-p)]
  88.    ["Save As..." vm-write-file t]
  89.    ["Quit" vm-quit-no-change t]
  90.    ["Save & Quit" vm-quit t]
  91.    "---"
  92.    "---"
  93.    ;; special string that marks the tail of this menu for
  94.    ;; vm-menu-install-visited-folders-menu.
  95.    "-------"
  96.    ))
  97.  
  98. (defconst vm-menu-dispose-menu
  99.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  100.            (list "Dispose"
  101.              "Dispose"
  102.              "---"
  103.              "---")
  104.          (list "Dispose"))))
  105.     (append
  106.      title
  107.      (list
  108.       ["Reply to Author" vm-reply vm-message-list]
  109.       ["Reply to All" vm-followup vm-message-list]
  110.       ["Reply to Author (citing original)" vm-reply-include-text vm-message-list]
  111.       ["Reply to All (citing original)" vm-followup-include-text vm-message-list]
  112.       ["Forward" vm-forward-message vm-message-list]
  113.       ["Resend" vm-resend-message vm-message-list]
  114.       ["Retry Bounce" vm-resend-bounced-message vm-message-list]
  115.       "---"
  116.       ["File" vm-save-message vm-message-list]
  117.       ["Delete" vm-delete-message vm-message-list]
  118.       ["Undelete"    vm-undelete-message vm-message-list]
  119.       ["Kill Current Subject" vm-kill-subject vm-message-list]
  120.       ["Mark Unread" vm-unread-message vm-message-list]
  121.       ["Edit" vm-edit-message vm-message-list]
  122.       ["Print" vm-print-message vm-message-list]
  123.       ["Pipe to Command" vm-pipe-message-to-command vm-message-list]
  124.       "---"
  125.       ["Burst Message as Digest" (vm-burst-digest "guess") vm-message-list]
  126.       ))))
  127.  
  128. (defconst vm-menu-motion-menu
  129.   '("Motion"
  130.     ["Page Up" vm-scroll-backward vm-message-list]
  131.     ["Page Down" vm-scroll-forward vm-message-list]
  132.     "----"
  133.     ["Beginning" vm-beginning-of-message vm-message-list]
  134.     ["End" vm-end-of-message vm-message-list]
  135.     "----"
  136.     ["Expose/Hide Headers" vm-expose-hidden-headers vm-message-list]
  137.     "----"
  138.     "----"
  139.     ["Next Message" vm-next-message t]
  140.     ["Previous Message"    vm-previous-message t]
  141.     "---"
  142.     ["Next, Same Subject" vm-next-message-same-subject t]
  143.     ["Previous, Same Subject" vm-previous-message-same-subject t]
  144.     "---"
  145.     ["Next Unread" vm-next-unread-message t]
  146.     ["Previous Unread" vm-previous-unread-message t]
  147.     "---"
  148.     ["Next Message (no skip)" vm-next-message-no-skip t]
  149.     ["Previous Message (no skip)" vm-previous-message-no-skip t]
  150.     "---"
  151.     ["Go to Last Seen Message" vm-goto-message-last-seen t]
  152.     ["Go to Message" vm-goto-message t]
  153.     ["Go to Parent Message" vm-goto-parent-message t]
  154.     ))
  155.  
  156. (defconst vm-menu-virtual-menu
  157.   '("Virtual"
  158.     ["Visit Virtual Folder" vm-visit-virtual-folder t]
  159.     ["Create Virtual Folder" vm-create-virtual-folder t]
  160.     ["Apply Virtual Folder" vm-apply-virtual-folder t]
  161.     "---"
  162.     "---"
  163.     ;; special string that marks the tail of this menu for
  164.     ;; vm-menu-install-known-virtual-folders-menu.
  165.     "-------"
  166.     ))
  167.  
  168. (defconst vm-menu-send-menu
  169.   '("Send"
  170.     ["Compose" vm-mail t]
  171.     ["Continue Composing" vm-continue-composing-message vm-message-list]
  172.     ["Reply to Author" vm-reply vm-message-list]
  173.     ["Reply to All" vm-followup vm-message-list]
  174.     ["Reply to Author (citing original)" vm-reply-include-text vm-message-list]
  175.     ["Reply to All (citing original)" vm-followup-include-text vm-message-list]
  176.     ["Forward Message" vm-forward-message vm-message-list]
  177.     ["Resend Message" vm-resend-message vm-message-list]
  178.     ["Retry Bounced Message" vm-resend-bounced-message vm-message-list]
  179.     ["Send Digest (RFC934)" vm-send-rfc934-digest vm-message-list]
  180.     ["Send Digest (RFC1153)" vm-send-rfc1153-digest vm-message-list]
  181.     ))
  182.  
  183. (defconst vm-menu-mark-menu
  184.   '("Mark"
  185.     ["Next Command Uses Marks..." vm-next-command-uses-marks
  186.      :active vm-message-list
  187.      :style radio
  188.      :selected (eq last-command 'vm-next-command-uses-marks)]
  189.     "----"
  190.     ["Mark" vm-mark-message vm-message-list]
  191.     ["Unmark" vm-unmark-message vm-message-list]
  192.     ["Mark All" vm-mark-all-messages vm-message-list]
  193.     ["Clear All Marks" vm-clear-all-marks vm-message-list]
  194.     "----"
  195.     ["Mark Same Subject" vm-mark-messages-same-subject vm-message-list]
  196.     ["Unmark Same Subject" vm-unmark-messages-same-subject vm-message-list]
  197.     ["Mark Same Author" vm-mark-messages-same-author vm-message-list]
  198.     ["Unmark Same Author" vm-unmark-messages-same-author vm-message-list]
  199.     ["Mark Messages Matching..." vm-mark-matching-messages vm-message-list]
  200.     ["Unmark Messages Matching..." vm-unmark-matching-messages vm-message-list]
  201.     ["Mark Thread Subtree" vm-mark-thread-subtree vm-message-list]
  202.     ["Unmark Thread Subtree" vm-unmark-thread-subtree vm-message-list]
  203.     ))
  204.  
  205. (defconst vm-menu-label-menu
  206.   '("Label"
  207.     ["Add Label" vm-add-message-labels vm-message-list]
  208.     ["Remove Label" vm-delete-message-labels vm-message-list]
  209.     ))
  210.  
  211. (defconst vm-menu-sort-menu
  212.   '("Sort"
  213.     ["By Multiple Fields..." vm-sort-messages vm-message-list]
  214.     "---"
  215.     ["By Date" (vm-sort-messages "date") vm-message-list]
  216.     ["By Subject" (vm-sort-messages "subject") vm-message-list]
  217.     ["By Author" (vm-sort-messages "author") vm-message-list]
  218.     ["By Recipients" (vm-sort-messages "recipients") vm-message-list]
  219.     ["By Lines" (vm-sort-messages "line-count") vm-message-list]
  220.     ["By Bytes" (vm-sort-messages "byte-count") vm-message-list]
  221.     "---"
  222.     ["By Date (backward)" (vm-sort-messages "reversed-date") vm-message-list]
  223.     ["By Subject (backward)" (vm-sort-messages "reversed-subject") vm-message-list]
  224.     ["By Author (backward)" (vm-sort-messages "reversed-author") vm-message-list]
  225.     ["By Recipients (backward)" (vm-sort-messages "reversed-recipients") vm-message-list]
  226.     ["By Lines (backwards)" (vm-sort-messages "reversed-line-count") vm-message-list]
  227.     ["By Bytes (backward)" (vm-sort-messages "reversed-byte-count") vm-message-list]
  228.     "---"
  229.     ["Toggle Threading" vm-toggle-threads-display t]
  230.     "---"
  231.     ["Revert to Physical Order" (vm-sort-messages "physical-order" t) vm-message-list]
  232.     ))
  233.  
  234. (defconst vm-menu-help-menu
  235.   '("Help!"
  236.     ["What Now?" vm-help t]
  237.     ["Describe Mode" describe-mode t]
  238.     ["Revert Folder (back to disk version)" revert-buffer (vm-menu-can-revert-p)]
  239.     ["Recover Folder (from auto-save file)" recover-file (vm-menu-can-recover-p)]
  240.     "---"
  241.     ["Save Folder & Quit" vm-quit t]
  242.     ["Quit Without Saving" vm-quit-no-change t]
  243.     ))
  244.  
  245. (defconst vm-menu-undo-menu
  246.   ["Undo" vm-undo (vm-menu-can-undo-p)]
  247.   )
  248.  
  249. (defconst vm-menu-emacs-button
  250.   ["XEmacs" vm-menu-toggle-menubar t]
  251.   )
  252.  
  253. (defconst vm-menu-vm-button
  254.   ["VM" vm-menu-toggle-menubar t]
  255.   )
  256.  
  257. (defconst vm-menu-mail-menu
  258.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  259.            (list "Mail Commands"
  260.              "Mail Commands"
  261.              "---"
  262.              "---")
  263.          (list "Mail Commands"))))
  264.     (append
  265.      title
  266.      (list ["Send and Exit" vm-mail-send-and-exit (vm-menu-can-send-mail-p)]
  267.        ["Send, Keep Composing" vm-mail-send (vm-menu-can-send-mail-p)]
  268.        ["Cancel" kill-buffer t]
  269.        "----"
  270.        "Go to Field:"
  271.        "----"
  272.        ["      To:" mail-to t]
  273.        ["      Subject:" mail-subject    t]
  274.        ["      CC:" mail-cc t]
  275.        ["      BCC:" mail-bcc t]
  276.        ["      Reply-To:" mail-replyto t]
  277.        ["      Text" mail-text t]
  278.        "----"
  279.        ["Yank Original" vm-menu-yank-original vm-reply-list]
  280.        ["Fill Yanked Message" mail-fill-yanked-message t]
  281.        ["Insert Signature"    mail-signature t]
  282.        ["Insert File..." insert-file t]
  283.        ["Insert Buffer..."    insert-buffer t]
  284.        ))))
  285.  
  286. (defconst vm-menu-url-browser-menu
  287.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  288.            (list "Send URL to ..."
  289.              "Send URL to ..."
  290.              "---"
  291.              "---")
  292.          (list "Send URL to ...")))
  293.     (w3 (cond ((fboundp 'w3-fetch-other-frame)
  294.            'w3-fetch-other-frame)
  295.           ((fboundp 'w3-fetch)
  296.            'w3-fetch)
  297.           (t 'w3-fetch-other-frame))))
  298.     (append
  299.      title
  300.      (list (vector "Emacs W3"
  301.            (list 'vm-mouse-send-url-at-position
  302.              '(point)
  303.              (list 'quote w3))
  304.            (list 'fboundp (list 'quote w3)))
  305.        ["Mosaic"
  306.         (vm-mouse-send-url-at-position (point)
  307.                        'vm-mouse-send-url-to-mosaic)
  308.         t]
  309.        ["Netscape"
  310.         (vm-mouse-send-url-at-position (point)
  311.                        'vm-mouse-send-url-to-netscape)
  312.         t]))))
  313.  
  314. (defconst vm-menu-subject-menu
  315.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  316.            (list "Take Action on Subject..."
  317.              "Take Action on Subject..."
  318.              "---"
  319.              "---")
  320.          (list "Take Action on Subject..."))))
  321.     (append
  322.      title
  323.      (list
  324.       ["Kill Subject" vm-kill-subject vm-message-list]
  325.       ["Next Message, Same Subject" vm-next-message-same-subject
  326.        vm-message-list]
  327.       ["Previous Message, Same Subject" vm-previous-message-same-subject
  328.        vm-message-list]
  329.       ["Mark Messages, Same Subject" vm-mark-messages-same-subject
  330.        vm-message-list]
  331.       ["Unmark Messages, Same Subject" vm-unmark-messages-same-subject
  332.        vm-message-list]
  333.       ["Virtual Folder, Matching Subject" vm-menu-create-subject-virtual-folder
  334.        vm-message-list]
  335.       ))))
  336.  
  337. (defconst vm-menu-author-menu
  338.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  339.            (list "Take Action on Author..."
  340.              "Take Action on Author..."
  341.              "---"
  342.              "---")
  343.          (list "Take Action on Author..."))))
  344.     (append
  345.      title
  346.      (list
  347.       ["Mark Messages, Same Author" vm-mark-messages-same-author
  348.        vm-message-list]
  349.       ["Unmark Messages, Same Author" vm-unmark-messages-same-author
  350.        vm-message-list]
  351.       ["Virtual Folder, Matching Author" vm-menu-create-author-virtual-folder
  352.        vm-message-list]
  353.       ))))
  354.  
  355. (defvar vm-menu-vm-menubar nil)
  356.  
  357. (defconst vm-menu-vm-menu
  358.   (let ((title (if (vm-menu-fsfemacs-menus-p)
  359.            (list "VM"
  360.              "VM"
  361.              "---"
  362.              "---")
  363.          (list "VM"))))
  364.     (append title
  365.         (list vm-menu-folder-menu
  366.           vm-menu-motion-menu
  367.           vm-menu-send-menu
  368.           vm-menu-mark-menu
  369.           vm-menu-label-menu
  370.           vm-menu-sort-menu
  371.           vm-menu-virtual-menu
  372.           vm-menu-undo-menu
  373.           vm-menu-dispose-menu
  374.           "---"
  375.           "---"
  376.           vm-menu-help-menu))))
  377.  
  378. (defvar vm-mode-menu-map nil)
  379.  
  380. (defun vm-menu-run-command (command &rest args)
  381.   "Run COMMAND almost interactively, with ARGS.
  382. call-interactive can't be used unfortunately, but this-command is
  383. set to the command name so that window configuration will be done."
  384.   (setq this-command command)
  385.   (apply command args))
  386.  
  387. (defun vm-menu-can-revert-p ()
  388.   (save-excursion
  389.     (vm-check-for-killed-folder)
  390.     (vm-select-folder-buffer)
  391.     (and (buffer-modified-p) buffer-file-name)))
  392.  
  393. (defun vm-menu-can-recover-p ()
  394.   (save-excursion
  395.     (vm-check-for-killed-folder)
  396.     (vm-select-folder-buffer)
  397.     (and buffer-file-name
  398.      buffer-auto-save-file-name
  399.      (file-newer-than-file-p
  400.       buffer-auto-save-file-name
  401.       buffer-file-name))))
  402.  
  403. (defun vm-menu-can-save-p ()
  404.   (save-excursion
  405.     (vm-check-for-killed-folder)
  406.     (vm-select-folder-buffer)
  407.     (or (eq major-mode 'vm-virtual-mode)
  408.     (buffer-modified-p))))
  409.  
  410. (defun vm-menu-can-get-new-mail-p ()
  411.   (save-excursion
  412.     (vm-check-for-killed-folder)
  413.     (vm-select-folder-buffer)
  414.     (or (eq major-mode 'vm-virtual-mode)
  415.     (and (not vm-block-new-mail) (not vm-folder-read-only)))))
  416.  
  417. (defun vm-menu-can-undo-p ()
  418.   (save-excursion
  419.     (vm-check-for-killed-folder)
  420.     (vm-select-folder-buffer)
  421.     vm-undo-record-list))
  422.  
  423. (defun vm-menu-yank-original ()
  424.   (interactive)
  425.   (save-excursion
  426.     (let ((mlist vm-reply-list))
  427.       (while mlist
  428.     (vm-yank-message (car mlist))
  429.     (goto-char (point-max))
  430.     (setq mlist (cdr mlist))))))
  431.  
  432. (defun vm-menu-can-send-mail-p ()
  433.   (save-match-data
  434.     (catch 'done
  435.       (let ((headers '("to" "cc" "bcc" "resent-to" "resent-cc" "resent-bcc"))
  436.         h)
  437.     (while headers
  438.       (setq h (mail-fetch-field (car headers)))
  439.       (and (stringp h) (string-match "[^ \t\n,]" h)
  440.            (throw 'done t))
  441.       (setq headers (cdr headers)))
  442.     nil ))))
  443.  
  444. (defun vm-menu-create-subject-virtual-folder ()
  445.   (interactive)
  446.   (vm-select-folder-buffer)
  447.   (setq this-command 'vm-create-virtual-folder)
  448.   (vm-create-virtual-folder 'subject (regexp-quote
  449.                       (vm-so-sortable-subject
  450.                        (car vm-message-pointer)))))
  451.  
  452. (defun vm-menu-create-author-virtual-folder ()
  453.   (interactive)
  454.   (vm-select-folder-buffer)
  455.   (setq this-command 'vm-create-virtual-folder)
  456.   (vm-create-virtual-folder 'author (regexp-quote
  457.                      (vm-su-from (car vm-message-pointer)))))
  458.  
  459. (defun vm-menu-xemacs-global-menubar ()
  460.   (save-excursion
  461.     (set-buffer (get-buffer-create "*scratch*"))
  462.     current-menubar))
  463.  
  464. (defun vm-menu-fsfemacs-global-menubar ()
  465.   (lookup-key (current-global-map) [menu-bar]))
  466.  
  467. (defun vm-menu-initialize-vm-mode-menu-map ()
  468.   (if (null vm-mode-menu-map)
  469.       (let ((map (make-sparse-keymap))
  470.         (dummy (make-sparse-keymap)))
  471.     ;; initialize all the vm-menu-fsfemacs-*-menu variables
  472.     ;; with the menus.
  473.     (vm-easy-menu-define vm-menu-fsfemacs-help-menu (list dummy) nil
  474.                  vm-menu-help-menu)
  475.     (vm-easy-menu-define vm-menu-fsfemacs-dispose-menu (list dummy) nil
  476.                  (cons "Dispose" (nthcdr 4 vm-menu-dispose-menu)))
  477.     (vm-easy-menu-define vm-menu-fsfemacs-dispose-popup-menu (list dummy) nil
  478.                  vm-menu-dispose-menu)
  479. ;;    (vm-easy-menu-define vm-menu-fsfemacs-undo-menu (list dummy) nil
  480. ;;                 (list "Undo" vm-menu-undo-menu))
  481.     (vm-easy-menu-define vm-menu-fsfemacs-virtual-menu (list dummy) nil
  482.                  vm-menu-virtual-menu)
  483.     (vm-easy-menu-define vm-menu-fsfemacs-sort-menu (list dummy) nil
  484.                  vm-menu-sort-menu)
  485.     (vm-easy-menu-define vm-menu-fsfemacs-label-menu (list dummy) nil
  486.                  vm-menu-label-menu)
  487.     (vm-easy-menu-define vm-menu-fsfemacs-mark-menu (list dummy) nil
  488.                  vm-menu-mark-menu)
  489.     (vm-easy-menu-define vm-menu-fsfemacs-send-menu (list dummy) nil
  490.                  vm-menu-send-menu)
  491.     (vm-easy-menu-define vm-menu-fsfemacs-motion-menu (list dummy) nil
  492.                  vm-menu-motion-menu)
  493. ;;    (vm-easy-menu-define vm-menu-fsfemacs-folders-menu (list dummy) nil
  494. ;;                 vm-menu-folders-menu)
  495.     (vm-easy-menu-define vm-menu-fsfemacs-folder-menu (list dummy) nil
  496.                  vm-menu-folder-menu)
  497.     (vm-easy-menu-define vm-menu-fsfemacs-vm-menu (list dummy) nil
  498.                  vm-menu-vm-menu)
  499.     ;; for mail mode
  500.     (vm-easy-menu-define vm-menu-fsfemacs-mail-menu (list dummy) nil
  501.                  vm-menu-mail-menu)
  502.     ;; subject menu
  503.     (vm-easy-menu-define vm-menu-fsfemacs-subject-menu (list dummy) nil
  504.                  vm-menu-subject-menu)
  505.     ;; author menu
  506.     (vm-easy-menu-define vm-menu-fsfemacs-author-menu (list dummy) nil
  507.                  vm-menu-author-menu)
  508.     ;; url browser menu
  509.     (vm-easy-menu-define vm-menu-fsfemacs-url-browser-menu (list dummy) nil
  510.                  vm-menu-url-browser-menu)
  511.     ;; block the global menubar entries in the map so that VM
  512.     ;; can take over the menubar if necessary.
  513.     (define-key map [rootmenu] (make-sparse-keymap))
  514.     (define-key map [rootmenu vm] (cons "VM" (make-sparse-keymap "VM")))
  515.     (define-key map [rootmenu vm file] 'undefined)
  516.     (define-key map [rootmenu vm files] 'undefined)
  517.     (define-key map [rootmenu vm search] 'undefined)
  518.     (define-key map [rootmenu vm edit] 'undefined)
  519.     (define-key map [rootmenu vm options] 'undefined)
  520.     (define-key map [rootmenu vm buffer] 'undefined)
  521.     (define-key map [rootmenu vm tools] 'undefined)
  522.     (define-key map [rootmenu vm help] 'undefined)
  523.     ;; 19.29 changed the tag for the Help menu.
  524.     (define-key map [rootmenu vm help-menu] 'undefined)
  525.     ;; now build VM's menu tree.
  526.     (let ((menu-alist
  527.            '((dispose
  528.           (cons "Dispose" vm-menu-fsfemacs-dispose-menu))
  529.          (folder
  530.           (cons "Folder" vm-menu-fsfemacs-folder-menu))
  531.          (help
  532.           (cons "Help!" vm-menu-fsfemacs-help-menu))
  533.          (label
  534.           (cons "Label" vm-menu-fsfemacs-label-menu))
  535.          (mark
  536.           (cons "Mark" vm-menu-fsfemacs-mark-menu))
  537.          (motion
  538.           (cons "Motion" vm-menu-fsfemacs-motion-menu))
  539.          (send
  540.           (cons "Send" vm-menu-fsfemacs-send-menu))
  541.          (sort
  542.           (cons "Sort" vm-menu-fsfemacs-sort-menu))
  543.          (virtual
  544.           (cons "Virtual" vm-menu-fsfemacs-virtual-menu))
  545.          (emacs
  546.           (cons "[Emacs]" 'vm-menu-toggle-menubar))
  547.          (undo
  548.           (cons "[Undo]" 'vm-undo))))
  549.           cons
  550.           (vec (vector 'rootmenu 'vm nil))
  551.           ;; menus appear in the opposite order that we
  552.           ;; define-key them.
  553.           (menu-list 
  554.            (if (consp vm-use-menus)
  555.            (reverse vm-use-menus)
  556.          (list 'help nil 'dispose 'undo 'virtual 'sort
  557.                'label 'mark 'send 'motion 'folder))))
  558.       (while menu-list
  559.         (if (null (car menu-list))
  560.         nil;; no flushright support in FSF Emacs
  561.           (aset vec 2 (intern (concat "vm-menubar-"
  562.                       (symbol-name
  563.                        (car menu-list)))))
  564.           (setq cons (assq (car menu-list) menu-alist))
  565.           (if cons
  566.           (define-key map vec (eval (car (cdr cons))))))
  567.         (setq menu-list (cdr menu-list))))
  568.     (setq vm-mode-menu-map map)
  569.     (run-hooks 'vm-menu-setup-hook))))
  570.  
  571. (defun vm-menu-make-xemacs-menubar ()
  572.   (let ((menu-alist
  573.      '((dispose . vm-menu-dispose-menu)
  574.        (folder . vm-menu-folder-menu)
  575.        (help . vm-menu-help-menu)
  576.        (label . vm-menu-label-menu)
  577.        (mark . vm-menu-mark-menu)
  578.        (motion . vm-menu-motion-menu)
  579.        (send . vm-menu-send-menu)
  580.        (sort . vm-menu-sort-menu)
  581.        (virtual . vm-menu-virtual-menu)
  582.        (emacs . vm-menu-emacs-button)
  583.        (undo . vm-menu-undo-menu)))
  584.     cons
  585.     (menubar nil)
  586.     (menu-list vm-use-menus))
  587.     (while menu-list
  588.       (if (null (car menu-list))
  589.       (setq menubar (cons nil menubar))
  590.     (setq cons (assq (car menu-list) menu-alist))
  591.     (if cons
  592.         (setq menubar (cons (symbol-value (cdr cons)) menubar))))
  593.       (setq menu-list (cdr menu-list)))
  594.     (nreverse menubar) ))
  595.  
  596. (defun vm-menu-popup-mode-menu (event)
  597.   (interactive "e")
  598.   (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
  599.      (set-buffer (window-buffer (event-window event)))
  600.      (and (event-point event) (goto-char (event-point event)))
  601.      (popup-mode-menu))
  602.     ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
  603.      (set-buffer (window-buffer (posn-window (event-start event))))
  604.      (goto-char (posn-point (event-start event)))
  605.      (vm-menu-popup-fsfemacs-menu event))))
  606.  
  607. (defun vm-menu-popup-context-menu (event)
  608.   (interactive "e")
  609.   ;; We should not need to do anything here for XEmacs.  The
  610.   ;; default binding of mouse-3 is popup-mode-menu which does
  611.   ;; what we want for the normal case.  For special contexts,
  612.   ;; like when the mouse is over an URL, XEmacs has local keymap
  613.   ;; support for extents.  Any context sensitive area should be
  614.   ;; contained in an extent with a keymap that has mouse-3 bound
  615.   ;; to a function that will pop up a context sensitive menu.
  616.   (cond ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
  617.      (set-buffer (window-buffer (posn-window (event-start event))))
  618.      (goto-char (posn-point (event-start event)))
  619.      (let (o-list o menu (found nil))
  620.        (setq o-list (overlays-at (point)))
  621.        (while (and o-list (not found))
  622.          (cond ((overlay-get (car o-list) 'vm-url)
  623.             (setq found t)
  624.             (vm-menu-popup-url-browser-menu event))
  625.            ((setq menu (overlay-get (car o-list) 'vm-header))
  626.             (setq found t)
  627.             (vm-menu-popup-fsfemacs-menu event menu)))
  628.          (setq o-list (cdr o-list)))
  629.        (and (not found) (vm-menu-popup-fsfemacs-menu event))))))
  630.  
  631. ;; to quiet the byte-compiler
  632. (defvar vm-menu-fsfemacs-url-browser-menu)
  633.  
  634. (defun vm-menu-popup-url-browser-menu (event)
  635.   (interactive "e")
  636.   (cond ((and (vm-menu-xemacs-menus-p) vm-use-menus)
  637.      ;; Must select window instead of just set-buffer because
  638.      ;; popup-menu returns before the user has made a
  639.      ;; selection.  This will cause the command loop to
  640.      ;; resume which might undo what set-buffer does.
  641.      (select-window (event-window event))
  642.      (and (event-point event) (goto-char (event-point event)))
  643.      (popup-menu vm-menu-url-browser-menu))
  644.     ((and (vm-menu-fsfemacs-menus-p) vm-use-menus)
  645.      (set-buffer (window-buffer (posn-window (event-start event))))
  646.      (goto-char (posn-point (event-start event)))
  647.      (vm-menu-popup-fsfemacs-menu
  648.       event vm-menu-fsfemacs-url-browser-menu))))
  649.  
  650. ;; to quiet the byte-compiler
  651. (defvar vm-menu-fsfemacs-mail-menu)
  652. (defvar vm-menu-fsfemacs-dispose-popup-menu)
  653. (defvar vm-menu-fsfemacs-vm-menu)
  654.  
  655. (defun vm-menu-popup-fsfemacs-menu (event &optional menu)
  656.   (interactive "e")
  657.   (set-buffer (window-buffer (posn-window (event-start event))))
  658.   (goto-char (posn-point (event-start event)))
  659.   (let ((map (or menu mode-popup-menu))
  660.     key command func)
  661.     (setq key (x-popup-menu event map)
  662.       key (apply 'vector key)
  663.           command (lookup-key map key)
  664.       func (and (symbolp command) (symbol-function command)))
  665.     (cond ((null func) (setq this-command last-command))
  666.       ((symbolp func)
  667.        (setq this-command func)
  668.        (call-interactively this-command))
  669.       (t
  670.        (call-interactively command)))))
  671.  
  672. (defun vm-menu-mode-menu ()
  673.   (if (vm-menu-xemacs-menus-p)
  674.       (cond ((eq major-mode 'mail-mode)
  675.          vm-menu-mail-menu)
  676.         ((memq major-mode '(vm-mode vm-summary-mode vm-virtual-mode))
  677.          vm-menu-dispose-menu)
  678.         (t vm-menu-vm-menu))
  679.     (cond ((eq major-mode 'mail-mode)
  680.        vm-menu-fsfemacs-mail-menu)
  681.       ((memq major-mode '(vm-mode vm-summary-mode vm-virtual-mode))
  682.        vm-menu-fsfemacs-dispose-popup-menu)
  683.       (t vm-menu-fsfemacs-vm-menu))))
  684.  
  685. (defun vm-menu-set-menubar-dirty-flag ()
  686.   (cond ((vm-menu-xemacs-menus-p)
  687.      (set-menubar-dirty-flag))
  688.     ((vm-menu-fsfemacs-menus-p)
  689.      (force-mode-line-update))))
  690.  
  691. (defun vm-menu-toggle-menubar (&optional buffer)
  692.   (interactive)
  693.   (if buffer
  694.       (set-buffer buffer)
  695.     (vm-select-folder-buffer))
  696.   (cond ((vm-menu-xemacs-menus-p)
  697.      (if (null (car (find-menu-item current-menubar '("XEmacs"))))
  698.          (set-buffer-menubar vm-menu-vm-menubar)
  699.        (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar)))
  700.        (condition-case nil
  701.            (add-menu-button nil vm-menu-vm-button nil)
  702.          (void-function
  703.           (add-menu-item nil "VM" 'vm-menu-toggle-menubar t))))
  704.      (vm-menu-set-menubar-dirty-flag)
  705.      (vm-check-for-killed-summary)
  706.      (and vm-summary-buffer
  707.           (vm-menu-toggle-menubar vm-summary-buffer)))
  708.     ((vm-menu-fsfemacs-menus-p)
  709.      (if (not (eq (lookup-key vm-mode-map [menu-bar])
  710.               (lookup-key vm-mode-menu-map [rootmenu vm])))
  711.          (define-key vm-mode-map [menu-bar]
  712.            (lookup-key vm-mode-menu-map [rootmenu vm]))
  713.        (define-key vm-mode-map [menu-bar]
  714.          (make-sparse-keymap))
  715.        (define-key vm-mode-map [menu-bar vm]
  716.          (cons "[VM]" 'vm-menu-toggle-menubar)))
  717.      (vm-menu-set-menubar-dirty-flag))))
  718.  
  719. (defun vm-menu-install-menubar ()
  720.   (cond ((vm-menu-xemacs-menus-p)
  721.      (setq vm-menu-vm-menubar (vm-menu-make-xemacs-menubar))
  722.      (set-buffer-menubar vm-menu-vm-menubar))
  723.     ((and (vm-menu-fsfemacs-menus-p)
  724.           ;; menus only need to be installed once for FSF Emacs
  725.           (not (fboundp 'vm-menu-undo-menu)))
  726.      (vm-menu-initialize-vm-mode-menu-map)
  727.      (define-key vm-mode-map [menu-bar]
  728.        (lookup-key vm-mode-menu-map [rootmenu vm])))))
  729.  
  730. (defun vm-menu-install-menubar-item ()
  731.   (cond ((and (vm-menu-xemacs-menus-p) (vm-menu-xemacs-global-menubar))
  732.      (set-buffer-menubar (copy-sequence (vm-menu-xemacs-global-menubar)))
  733.      (add-menu nil "VM" (cdr vm-menu-vm-menu)))
  734.     ((and (vm-menu-fsfemacs-menus-p)
  735.           ;; menus only need to be installed once for FSF Emacs
  736.           (not (fboundp 'vm-menu-undo-menu)))
  737.      (vm-menu-initialize-vm-mode-menu-map)
  738.      (define-key vm-mode-map [menu-bar]
  739.        (lookup-key vm-mode-menu-map [rootmenu])))))
  740.  
  741. (defun vm-menu-install-vm-mode-menu ()
  742.   ;; nothing to do here.
  743.   ;; handled in vm-mouse.el
  744.   (cond ((vm-menu-xemacs-menus-p)
  745.      t )
  746.     ((vm-menu-fsfemacs-menus-p)
  747.      t )))
  748.  
  749. (defun vm-menu-install-mail-mode-menu ()
  750.   (cond ((vm-menu-xemacs-menus-p)
  751.      ;; mail-mode doesn't have mode-popup-menu bound to
  752.      ;; mouse-3 by default.  fix that.
  753.      (define-key vm-mail-mode-map 'button3 'popup-mode-menu)
  754.      ;; put menu on menubar also.
  755.      (if (vm-menu-xemacs-global-menubar)
  756.          (progn
  757.            (set-buffer-menubar
  758.         (copy-sequence (vm-menu-xemacs-global-menubar)))
  759.            (add-menu nil "Mail" (cdr vm-menu-mail-menu))))
  760.      t )
  761.     ((vm-menu-fsfemacs-menus-p)
  762.      ;; I'd like to do this, but the result is a combination
  763.      ;; of the Emacs and VM Mail menus glued together.
  764.      ;; Poorly.
  765.      ;;(define-key vm-mail-mode-map [menu-bar mail]
  766.      ;;  (cons "Mail" vm-menu-fsfemacs-mail-menu))
  767.      (define-key vm-mail-mode-map [down-mouse-3]
  768.        'vm-menu-popup-mode-menu))))
  769.  
  770. (defun vm-menu-install-menus ()
  771.   (cond ((consp vm-use-menus)
  772.      (vm-menu-install-vm-mode-menu)
  773.      (vm-menu-install-menubar)
  774.      (vm-menu-install-known-virtual-folders-menu))
  775.     ((eq vm-use-menus 1)
  776.      (vm-menu-install-vm-mode-menu)
  777.      (vm-menu-install-menubar-item)
  778.      (vm-menu-install-known-virtual-folders-menu))
  779.     (t nil)))
  780.  
  781. (defun vm-menu-install-known-virtual-folders-menu ()
  782.   (let ((folders (sort (mapcar 'car vm-virtual-folder-alist)
  783.                (function string-lessp)))
  784.     (menu nil)
  785.     tail
  786.     ;; special string indicating tail of Virtual menu
  787.     (special "-------"))
  788.     (while folders
  789.       (setq menu (cons (vector "    "
  790.                    (list 'vm-menu-run-command
  791.                      ''vm-visit-virtual-folder (car folders))
  792.                    t
  793.                    (car folders))
  794.                menu)
  795.         folders (cdr folders)))
  796.     (and menu (setq menu (nreverse menu)
  797.             menu (nconc (list "Visit:" "---") menu)))
  798.     (setq tail (vm-member special vm-menu-virtual-menu))
  799.     (if (and menu tail)
  800.     (progn
  801.       (setcdr tail menu)
  802.       (vm-menu-set-menubar-dirty-flag)
  803.       (cond ((vm-menu-fsfemacs-menus-p)
  804.          (makunbound 'vm-menu-fsfemacs-virtual-menu)
  805.          (vm-easy-menu-define vm-menu-fsfemacs-virtual-menu
  806.                       (list (make-sparse-keymap))
  807.                       nil
  808.                       vm-menu-virtual-menu)
  809.          (define-key vm-mode-menu-map [rootmenu vm vm-menubar-virtual]
  810.            (cons "Virtual" vm-menu-fsfemacs-virtual-menu))))))))
  811.  
  812. (defun vm-menu-install-visited-folders-menu ()
  813.   (let ((folders (vm-delete-duplicates (copy-sequence vm-folder-history)))
  814.     (menu nil)
  815.     tail
  816.     spool-files
  817.     (i 0)
  818.     ;; special string indicating tail of Folder menu
  819.     (special "-------"))
  820.     (while (and folders (< i 10))
  821.       (setq menu (cons (vector "    "
  822.                    (list 'vm-menu-run-command
  823.                      ''vm-visit-folder (car folders))
  824.                    t
  825.                    (car folders))
  826.                menu)
  827.         folders (cdr folders)
  828.         i (1+ i)))
  829.     (and menu (setq menu (nreverse menu)
  830.             menu (nconc (list "Visit:" "---") menu)))
  831.     (setq spool-files (vm-spool-files)
  832.       folders (cond ((and (consp spool-files)
  833.                   (consp (car spool-files)))
  834.              (mapcar (function car) spool-files))
  835.             ((and (consp spool-files)
  836.                   (stringp (car spool-files))
  837.                   (stringp vm-primary-inbox))
  838.              (list vm-primary-inbox))
  839.             (t nil)))
  840.     (if (and menu folders)
  841.     (nconc menu (list "---" "---")))
  842.     (while folders
  843.       (setq menu (nconc menu
  844.             (list (vector "    "
  845.                       (list 'vm-menu-run-command
  846.                         ''vm-visit-folder (car folders))
  847.                       t
  848.                       (car folders))))
  849.         folders (cdr folders)))
  850.     (setq tail (vm-member special vm-menu-folder-menu))
  851.     (if (and menu tail)
  852.     (progn
  853.       (setcdr tail menu)
  854.       (vm-menu-set-menubar-dirty-flag)
  855.       (cond ((vm-menu-fsfemacs-menus-p)
  856.          (makunbound 'vm-menu-fsfemacs-folder-menu)
  857.          (vm-easy-menu-define vm-menu-fsfemacs-folder-menu
  858.                       (list (make-sparse-keymap))
  859.                       nil
  860.                       vm-menu-folder-menu)
  861.          (define-key vm-mode-menu-map [rootmenu vm vm-menubar-folder]
  862.            (cons "Folder" vm-menu-fsfemacs-folder-menu))))))))
  863.  
  864.  
  865. ;;; Muenkel Folders menu code
  866.  
  867. (defvar vm-menu-hm-no-hidden-dirs t
  868.   "*Hidden directories are suppressed in the folder menus, if non nil.")
  869.  
  870. (defvar vm-menu-hm-hidden-file-list '("^\\..*" ".*\\.~[0-9]+~"))
  871.  
  872. (defun vm-menu-hm-delete-folder (folder)
  873.   "Query deletes a folder."
  874.   (interactive "fDelete folder: ")
  875.   (if (file-exists-p folder)
  876.       (if (y-or-n-p (concat "Delete the folder " folder " ? "))
  877.       (progn
  878.         (if (file-directory-p folder)
  879.         (delete-directory folder)
  880.           (delete-file folder))
  881.         (message "Folder deleted.")
  882.         (vm-menu-hm-make-folder-menu)
  883.         (vm-menu-hm-install-menu)
  884.         )
  885.     (message "Aborted"))
  886.     (error "Folder %s does not exist." folder)
  887.     (vm-menu-hm-make-folder-menu)
  888.     (vm-menu-hm-install-menu)
  889.     ))
  890.     
  891.  
  892. (defun vm-menu-hm-rename-folder (folder)
  893.   "Rename a folder."
  894.   (interactive "fRename folder: ")
  895.   (if (file-exists-p folder)
  896.       (rename-file folder
  897.            (read-file-name (concat "Rename "
  898.                        folder
  899.                        " to ")
  900.                    (directory-file-name folder)
  901.                    folder))
  902.     (error "Folder %s does not exist." folder))
  903.   (vm-menu-hm-make-folder-menu)
  904.   (vm-menu-hm-install-menu)
  905.   )
  906.  
  907.  
  908. (defun vm-menu-hm-create-dir (parent-dir)
  909.   "Create a subdir in PARENT-DIR."
  910.   (interactive "DCreate new directory in: ")
  911.   (make-directory 
  912.    (expand-file-name (read-file-name "Create directory in %s called: "
  913.                      (concat parent-dir
  914.                          "/")))
  915.    t)
  916.   (vm-menu-hm-make-folder-menu)
  917.   (vm-menu-hm-install-menu)
  918.   )
  919.  
  920.  
  921. (defun vm-menu-hm-make-folder-menu ()
  922.   "Makes a menu with the mail folders of the directory `vm-folder-directory'."
  923.   (interactive)
  924.   (vm-unsaved-message "Building folders menu...")
  925.   (let ((folder-list (vm-menu-hm-tree-make-file-list vm-folder-directory))
  926.     (inbox-list (if (listp (car vm-spool-files))
  927.             (mapcar 'car vm-spool-files)
  928.               (list vm-primary-inbox))))
  929.     (setq vm-menu-folders-menu
  930.       (cons "Manipulate Folders"
  931.         (list (cons "Visit Inboxes  "
  932.                 (vm-menu-hm-tree-make-menu 
  933.                  inbox-list
  934.                  'vm-visit-folder
  935.                  t))
  936.               (cons "Visit Folder   "
  937.                 (vm-menu-hm-tree-make-menu 
  938.                  folder-list
  939.                  'vm-visit-folder
  940.                  t
  941.                  vm-menu-hm-no-hidden-dirs
  942.                  vm-menu-hm-hidden-file-list))
  943.               (cons "Save Message   "
  944.                 (vm-menu-hm-tree-make-menu 
  945.                  folder-list
  946.                  'vm-save-message
  947.                  t
  948.                  vm-menu-hm-no-hidden-dirs
  949.                  vm-menu-hm-hidden-file-list))
  950.               "----"
  951.               (cons "Delete Folder  "
  952.                 (vm-menu-hm-tree-make-menu 
  953.                  folder-list
  954.                  'vm-menu-hm-delete-folder
  955.                  t
  956.                  nil
  957.                  nil
  958.                  t
  959.                  ))
  960.               (cons "Rename Folder  "
  961.                 (vm-menu-hm-tree-make-menu 
  962.                  folder-list
  963.                  'vm-menu-hm-rename-folder
  964.                  t
  965.                  nil
  966.                  nil
  967.                  t
  968.                  ))
  969.               (cons "Make New Directory in..."
  970.                 (vm-menu-hm-tree-make-menu 
  971.                  (cons (list ".") folder-list)
  972.                  'vm-menu-hm-create-dir
  973.                  t
  974.                  nil
  975.                  '(".*")
  976.                  t
  977.                  ))
  978.               "----"
  979.               ["Rebuild Folders Menu" vm-menu-hm-make-folder-menu vm-folder-directory]
  980.               ))))
  981.   (vm-unsaved-message "Building folders menu... done")
  982.   (vm-menu-hm-install-menu))
  983.  
  984. (defun vm-menu-hm-install-menu ()
  985.   (cond ((vm-menu-xemacs-menus-p)
  986.      (cond ((car (find-menu-item current-menubar '("VM")))
  987.         (add-menu '("VM") "Folders"
  988.               (cdr vm-menu-folders-menu) "Motion"))
  989.            ((car (find-menu-item current-menubar
  990.                      '("Folder" "Manipulate Folders")))
  991.         (add-menu '("Folder") "Manipulate Folders"
  992.               (cdr vm-menu-folders-menu) "Motion"))))
  993.     ((vm-menu-fsfemacs-menus-p)
  994.      (vm-easy-menu-define vm-menu-fsfemacs-folders-menu
  995.                   (list (make-sparse-keymap))
  996.                   nil
  997.                   vm-menu-folders-menu)
  998.      (define-key vm-mode-menu-map [rootmenu vm folder folders]
  999.        (cons "Manipulate Folders" vm-menu-fsfemacs-folders-menu)))))
  1000.  
  1001.  
  1002. ;;; Muenkel tree-menu code
  1003.  
  1004. (defvar vm-menu-hm-tree-ls-flags "-aFLR" 
  1005.   "*A String with the flags used in the function
  1006. vm-menu-hm-tree-ls-in-temp-buffer for the ls command.
  1007. Be careful if you want to change this variable. 
  1008. The ls command must append a / on all files which are directories. 
  1009. The original flags are -aFLR.")
  1010.  
  1011.  
  1012. (defun vm-menu-hm-tree-ls-in-temp-buffer (dir temp-buffer)
  1013. "List the directory DIR in the TEMP-BUFFER."
  1014.   (switch-to-buffer temp-buffer)
  1015.   (erase-buffer)
  1016.   (let ((process-connection-type nil))
  1017.     (call-process "ls" nil temp-buffer nil vm-menu-hm-tree-ls-flags dir))
  1018.   (goto-char (point-min))
  1019.   (while (search-forward "//" nil t)
  1020.     (replace-match "/"))
  1021.   (goto-char (point-min))
  1022.   (while (re-search-forward "\\.\\.?/\n" nil t)
  1023.     (replace-match ""))
  1024.   (goto-char (point-min)))
  1025.  
  1026.  
  1027. (defvar vm-menu-hm-tree-temp-buffername "*tree*"
  1028.   "Name of the temp buffers in tree.")
  1029.  
  1030.  
  1031. (defun vm-menu-hm-tree-make-file-list-1 (root list)
  1032.   (let ((filename (buffer-substring (point) (progn
  1033.                           (end-of-line)
  1034.                           (point)))))
  1035.     (while (not (string= filename ""))
  1036.       (setq 
  1037.        list 
  1038.        (append
  1039.     list
  1040.     (list
  1041.      (cond ((char-equal (char-after (- (point) 1)) ?/)
  1042.         ;; Directory
  1043.         (setq filename (substring filename 0 (1- (length filename))))
  1044.         (save-excursion
  1045.           (search-forward (concat root filename ":"))
  1046.           (forward-line)
  1047.           (vm-menu-hm-tree-make-file-list-1 (concat root filename "/")
  1048.                         (list (vm-menu-hm-tree-menu-file-truename 
  1049.                                filename
  1050.                                root)))))
  1051.            ((char-equal (char-after (- (point) 1)) ?*)
  1052.         ;; Executable
  1053.         (setq filename (substring filename 0 (1- (length filename))))
  1054.         (vm-menu-hm-tree-menu-file-truename filename root))
  1055.            (t (vm-menu-hm-tree-menu-file-truename filename root))))))
  1056.       (forward-line)
  1057.       (setq filename (buffer-substring (point) (progn
  1058.                          (end-of-line)
  1059.                          (point)))))
  1060.     list))
  1061.  
  1062.  
  1063. (defun vm-menu-hm-tree-menu-file-truename (file &optional root)
  1064.   (file-truename (expand-file-name file root)))
  1065.  
  1066. (defun vm-menu-hm-tree-make-file-list (dir)
  1067.   "Makes a list with the files and subdirectories of DIR.
  1068. The list looks like: ((dirname1 file1 file2) 
  1069.                       file3
  1070.                       (dirname2 (dirname3 file4 file5) file6))"
  1071.   (save-window-excursion
  1072.     (setq dir (expand-file-name dir))
  1073.     (if (not (string= (substring dir -1) "/"))
  1074.     (setq dir (concat dir "/")))
  1075. ;;    (while (string-match "/$" dir)
  1076. ;;      (setq dir (substring dir 0 -1)))
  1077.     (vm-menu-hm-tree-ls-in-temp-buffer dir
  1078.                  (generate-new-buffer-name 
  1079.                   vm-menu-hm-tree-temp-buffername))
  1080.     (let ((list nil))
  1081.       (setq list (vm-menu-hm-tree-make-file-list-1 dir nil))
  1082.       (kill-buffer (current-buffer))
  1083.       list)))
  1084.  
  1085.  
  1086. (defun vm-menu-hm-tree-hide-file-p (filename re-hidden-file-list)
  1087.   "t, if one of the regexps in RE-HIDDEN-FILE-LIST matches the FILENAME."
  1088.   (cond ((not re-hidden-file-list) nil)
  1089.     ((string-match (car re-hidden-file-list) 
  1090.                (vm-menu-hm-tree-menu-file-truename filename)))
  1091.     (t (vm-menu-hm-tree-hide-file-p filename (cdr re-hidden-file-list)))))
  1092.  
  1093.  
  1094. (defun vm-menu-hm-tree-make-menu (dirlist 
  1095.                function 
  1096.                selectable 
  1097.                &optional 
  1098.                no-hidden-dirs
  1099.                re-hidden-file-list
  1100.                include-current-dir)
  1101.   "Returns a menu list.
  1102. Each item of the menu list has the form 
  1103.  [\"subdir\" (FUNCTION \"dir\") SELECTABLE].
  1104. Hidden directories (with a leading point) are suppressed, 
  1105. if NO-HIDDEN-DIRS are non nil. Also all files which are
  1106. matching a regexp in RE-HIDDEN-FILE-LIST are suppressed.
  1107. If INCLUDE-CURRENT-DIR non nil, then an additional command
  1108. for the current directory (.) is inserted."
  1109.   (let ((subdir nil)
  1110.     (menulist nil))
  1111.     (while (setq subdir (car dirlist))
  1112.       (setq dirlist (cdr dirlist))
  1113.       (cond ((and (stringp subdir)
  1114.           (not (vm-menu-hm-tree-hide-file-p subdir re-hidden-file-list)))
  1115.          (setq menulist
  1116.            (append menulist
  1117.                (list
  1118.                 (vector (file-name-nondirectory subdir)
  1119.                     (list function subdir)
  1120.                     selectable)))))
  1121.         ((and (listp subdir)
  1122.           (or (not no-hidden-dirs)
  1123.               (not (char-equal 
  1124.                 ?.
  1125.                 (string-to-char 
  1126.                  (file-name-nondirectory (car subdir))))))
  1127.           (setq menulist
  1128.             (append 
  1129.              menulist
  1130.              (list
  1131.               (cons (file-name-nondirectory (car subdir))
  1132.                 (if include-current-dir
  1133.                     (cons
  1134.                      (vector "."
  1135.                          (list function
  1136.                            (car subdir))
  1137.                          selectable)
  1138.                      (vm-menu-hm-tree-make-menu (cdr subdir)
  1139.                              function
  1140.                              selectable
  1141.                              no-hidden-dirs
  1142.                              re-hidden-file-list
  1143.                              include-current-dir
  1144.                              ))
  1145.                   (vm-menu-hm-tree-make-menu (cdr subdir)
  1146.                           function
  1147.                           selectable
  1148.                           no-hidden-dirs
  1149.                           re-hidden-file-list
  1150.                           ))))))))
  1151.         (t nil))
  1152.       )
  1153.     menulist
  1154.     )
  1155.   )
  1156.